home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / perl5 / Dpkg / IPC.pm < prev    next >
Encoding:
Perl POD Document  |  2012-09-17  |  10.5 KB  |  372 lines
  1. # Copyright ┬⌐ 2008-2009 Rapha├½l Hertzog <hertzog@debian.org>
  2. # Copyright ┬⌐ 2008 Frank Lichtenheld <djpig@debian.org>
  3. #
  4. # This program is free software; you can redistribute it and/or modify
  5. # it under the terms of the GNU General Public License as published by
  6. # the Free Software Foundation; either version 2 of the License, or
  7. # (at your option) any later version.
  8. #
  9. # This program is distributed in the hope that it will be useful,
  10. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. # GNU General Public License for more details.
  13. #
  14. # You should have received a copy of the GNU General Public License
  15. # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  16.  
  17. package Dpkg::IPC;
  18.  
  19. use strict;
  20. use warnings;
  21.  
  22. our $VERSION = "1.00";
  23.  
  24. use Dpkg::ErrorHandling;
  25. use Dpkg::Gettext;
  26.  
  27. use base qw(Exporter);
  28. our @EXPORT = qw(spawn wait_child);
  29.  
  30. =encoding utf8
  31.  
  32. =head1 NAME
  33.  
  34. Dpkg::IPC - helper functions for IPC
  35.  
  36. =head1 DESCRIPTION
  37.  
  38. Dpkg::IPC offers helper functions to allow you to execute
  39. other programs in an easy, yet flexible way, while hiding
  40. all the gory details of IPC (Inter-Process Communication)
  41. from you.
  42.  
  43. =head1 METHODS
  44.  
  45. =over 4
  46.  
  47. =item spawn
  48.  
  49. Creates a child process and executes another program in it.
  50. The arguments are interpreted as a hash of options, specifying
  51. how to handle the in and output of the program to execute.
  52. Returns the pid of the child process (unless the wait_child
  53. option was given).
  54.  
  55. Any error will cause the function to exit with one of the
  56. Dpkg::ErrorHandling functions.
  57.  
  58. Options:
  59.  
  60. =over 4
  61.  
  62. =item exec
  63.  
  64. Can be either a scalar, i.e. the name of the program to be
  65. executed, or an array reference, i.e. the name of the program
  66. plus additional arguments. Note that the program will never be
  67. executed via the shell, so you can't specify additional arguments
  68. in the scalar string and you can't use any shell facilities like
  69. globbing.
  70.  
  71. Mandatory Option.
  72.  
  73. =item from_file, to_file, error_to_file
  74.  
  75. Filename as scalar. Standard input/output/error of the
  76. child process will be redirected to the file specified.
  77.  
  78. =item from_handle, to_handle, error_to_handle
  79.  
  80. Filehandle. Standard input/output/error of the child process will be
  81. dup'ed from the handle.
  82.  
  83. =item from_pipe, to_pipe, error_to_pipe
  84.  
  85. Scalar reference or object based on IO::Handle. A pipe will be opened for
  86. each of the two options and either the reading (C<to_pipe> and
  87. C<error_to_pipe>) or the writing end (C<from_pipe>) will be returned in
  88. the referenced scalar. Standard input/output/error of the child process
  89. will be dup'ed to the other ends of the pipes.
  90.  
  91. =item from_string, to_string, error_to_string
  92.  
  93. Scalar reference. Standard input/output/error of the child
  94. process will be redirected to the string given as reference. Note
  95. that it wouldn't be strictly necessary to use a scalar reference
  96. for C<from_string>, as the string is not modified in any way. This was
  97. chosen only for reasons of symmetry with C<to_string> and
  98. C<error_to_string>. C<to_string> and C<error_to_string> imply the
  99. C<wait_child> option.
  100.  
  101. =item wait_child
  102.  
  103. Scalar. If containing a true value, wait_child() will be called before
  104. returning. The return value will of spawn() will be a true value,
  105. but not the pid.
  106.  
  107. =item nocheck
  108.  
  109. Scalar. Option of the wait_child() call.
  110.  
  111. =item timeout
  112.  
  113. Scalar. Option of the wait_child() call.
  114.  
  115. =item chdir
  116.  
  117. Scalar. The child process will chdir in the indicated directory before
  118. calling exec.
  119.  
  120. =item env
  121.  
  122. Hash reference. The child process will populate %ENV with the items of the
  123. hash before calling exec. This allows exporting environment variables.
  124.  
  125. =item delete_env
  126.  
  127. Array reference. The child process will remove all environment variables
  128. listed in the array before calling exec.
  129.  
  130. =back
  131.  
  132. =cut
  133.  
  134. sub _sanity_check_opts {
  135.     my (%opts) = @_;
  136.  
  137.     internerr("exec parameter is mandatory in spawn()")
  138.     unless $opts{"exec"};
  139.  
  140.     my $to = my $error_to = my $from = 0;
  141.     foreach (qw(file handle string pipe)) {
  142.     $to++ if $opts{"to_$_"};
  143.     $error_to++ if $opts{"error_to_$_"};
  144.     $from++ if $opts{"from_$_"};
  145.     }
  146.     internerr("not more than one of to_* parameters is allowed")
  147.     if $to > 1;
  148.     internerr("not more than one of error_to_* parameters is allowed")
  149.     if $error_to > 1;
  150.     internerr("not more than one of from_* parameters is allowed")
  151.     if $from > 1;
  152.  
  153.     foreach (qw(to_string error_to_string from_string)) {
  154.     if (exists $opts{$_} and
  155.         (!ref($opts{$_}) or ref($opts{$_}) ne 'SCALAR')) {
  156.         internerr("parameter $_ must be a scalar reference");
  157.     }
  158.     }
  159.  
  160.     foreach (qw(to_pipe error_to_pipe from_pipe)) {
  161.     if (exists $opts{$_} and
  162.         (!ref($opts{$_}) or (ref($opts{$_}) ne 'SCALAR' and
  163.                  not $opts{$_}->isa("IO::Handle")))) {
  164.         internerr("parameter $_ must be a scalar reference or an IO::Handle object");
  165.     }
  166.     }
  167.  
  168.     if (exists $opts{"timeout"} and defined($opts{"timeout"}) and
  169.         $opts{"timeout"} !~ /^\d+$/) {
  170.     internerr("parameter timeout must be an integer");
  171.     }
  172.  
  173.     if (exists $opts{"env"} and ref($opts{"env"}) ne 'HASH') {
  174.     internerr("parameter env must be a hash reference");
  175.     }
  176.  
  177.     if (exists $opts{"delete_env"} and ref($opts{"delete_env"}) ne 'ARRAY') {
  178.     internerr("parameter delete_env must be an array reference");
  179.     }
  180.  
  181.     return %opts;
  182. }
  183.  
  184. sub spawn {
  185.     my (%opts) = _sanity_check_opts(@_);
  186.     $opts{"close_in_child"} ||= [];
  187.     my @prog;
  188.     if (ref($opts{"exec"}) =~ /ARRAY/) {
  189.     push @prog, @{$opts{"exec"}};
  190.     } elsif (not ref($opts{"exec"})) {
  191.     push @prog, $opts{"exec"};
  192.     } else {
  193.     internerr("invalid exec parameter in spawn()");
  194.     }
  195.     my ($from_string_pipe, $to_string_pipe, $error_to_string_pipe);
  196.     if ($opts{"to_string"}) {
  197.     $opts{"to_pipe"} = \$to_string_pipe;
  198.     $opts{"wait_child"} = 1;
  199.     }
  200.     if ($opts{"error_to_string"}) {
  201.     $opts{"error_to_pipe"} = \$error_to_string_pipe;
  202.     $opts{"wait_child"} = 1;
  203.     }
  204.     if ($opts{"from_string"}) {
  205.     $opts{"from_pipe"} = \$from_string_pipe;
  206.     }
  207.     # Create pipes if needed
  208.     my ($input_pipe, $output_pipe, $error_pipe);
  209.     if ($opts{"from_pipe"}) {
  210.     pipe($opts{"from_handle"}, $input_pipe) ||
  211.         syserr(_g("pipe for %s"), "@prog");
  212.     ${$opts{"from_pipe"}} = $input_pipe;
  213.     push @{$opts{"close_in_child"}}, $input_pipe;
  214.     }
  215.     if ($opts{"to_pipe"}) {
  216.     pipe($output_pipe, $opts{"to_handle"}) ||
  217.         syserr(_g("pipe for %s"), "@prog");
  218.     ${$opts{"to_pipe"}} = $output_pipe;
  219.     push @{$opts{"close_in_child"}}, $output_pipe;
  220.     }
  221.     if ($opts{"error_to_pipe"}) {
  222.     pipe($error_pipe, $opts{"error_to_handle"}) ||
  223.         syserr(_g("pipe for %s"), "@prog");
  224.     ${$opts{"error_to_pipe"}} = $error_pipe;
  225.     push @{$opts{"close_in_child"}}, $error_pipe;
  226.     }
  227.     # Fork and exec
  228.     my $pid = fork();
  229.     syserr(_g("cannot fork for %s"), "@prog") unless defined $pid;
  230.     if (not $pid) {
  231.     # Define environment variables
  232.     if ($opts{"env"}) {
  233.         foreach (keys %{$opts{"env"}}) {
  234.         $ENV{$_} = $opts{"env"}{$_};
  235.         }
  236.     }
  237.     if ($opts{"delete_env"}) {
  238.         delete $ENV{$_} foreach (@{$opts{"delete_env"}});
  239.     }
  240.     # Change the current directory
  241.     if ($opts{"chdir"}) {
  242.         chdir($opts{"chdir"}) || syserr(_g("chdir to %s"), $opts{"chdir"});
  243.     }
  244.     # Redirect STDIN if needed
  245.     if ($opts{"from_file"}) {
  246.         open(STDIN, "<", $opts{"from_file"}) ||
  247.         syserr(_g("cannot open %s"), $opts{"from_file"});
  248.     } elsif ($opts{"from_handle"}) {
  249.         open(STDIN, "<&", $opts{"from_handle"}) || syserr(_g("reopen stdin"));
  250.         close($opts{"from_handle"}); # has been duped, can be closed
  251.     }
  252.     # Redirect STDOUT if needed
  253.     if ($opts{"to_file"}) {
  254.         open(STDOUT, ">", $opts{"to_file"}) ||
  255.         syserr(_g("cannot write %s"), $opts{"to_file"});
  256.     } elsif ($opts{"to_handle"}) {
  257.         open(STDOUT, ">&", $opts{"to_handle"}) || syserr(_g("reopen stdout"));
  258.         close($opts{"to_handle"}); # has been duped, can be closed
  259.     }
  260.     # Redirect STDERR if needed
  261.     if ($opts{"error_to_file"}) {
  262.         open(STDERR, ">", $opts{"error_to_file"}) ||
  263.         syserr(_g("cannot write %s"), $opts{"error_to_file"});
  264.     } elsif ($opts{"error_to_handle"}) {
  265.         open(STDERR, ">&", $opts{"error_to_handle"}) || syserr(_g("reopen stdout"));
  266.         close($opts{"error_to_handle"}); # has been duped, can be closed
  267.     }
  268.     # Close some inherited filehandles
  269.     close($_) foreach (@{$opts{"close_in_child"}});
  270.     # Execute the program
  271.     exec({ $prog[0] } @prog) or syserr(_g("exec %s"), "@prog");
  272.     }
  273.     # Close handle that we can't use any more
  274.     close($opts{"from_handle"}) if exists $opts{"from_handle"};
  275.     close($opts{"to_handle"}) if exists $opts{"to_handle"};
  276.     close($opts{"error_to_handle"}) if exists $opts{"error_to_handle"};
  277.  
  278.     if ($opts{"from_string"}) {
  279.     print $from_string_pipe ${$opts{"from_string"}};
  280.     close($from_string_pipe);
  281.     }
  282.     if ($opts{"to_string"}) {
  283.     local $/ = undef;
  284.     ${$opts{"to_string"}} = readline($to_string_pipe);
  285.     }
  286.     if ($opts{"error_to_string"}) {
  287.     local $/ = undef;
  288.     ${$opts{"error_to_string"}} = readline($error_to_string_pipe);
  289.     }
  290.     if ($opts{"wait_child"}) {
  291.     my $cmdline = "@prog";
  292.     if ($opts{"env"}) {
  293.         foreach (keys %{$opts{"env"}}) {
  294.         $cmdline = "$_=\"" . $opts{"env"}{$_} . "\" $cmdline";
  295.         }
  296.     }
  297.     wait_child($pid, nocheck => $opts{"nocheck"},
  298.                    timeout => $opts{"timeout"}, cmdline => $cmdline);
  299.     return 1;
  300.     }
  301.  
  302.     return $pid;
  303. }
  304.  
  305.  
  306. =item wait_child
  307.  
  308. Takes as first argument the pid of the process to wait for.
  309. Remaining arguments are taken as a hash of options. Returns
  310. nothing. Fails if the child has been ended by a signal or
  311. if it exited non-zero.
  312.  
  313. Options:
  314.  
  315. =over 4
  316.  
  317. =item cmdline
  318.  
  319. String to identify the child process in error messages.
  320. Defaults to "child process".
  321.  
  322. =item nocheck
  323.  
  324. If true do not check the return status of the child (and thus
  325. do not fail it it has been killed or if it exited with a
  326. non-zero return code).
  327.  
  328. =item timeout
  329.  
  330. Set a maximum time to wait for the process, after that fail
  331. with an error message.
  332.  
  333. =back
  334.  
  335. =cut
  336.  
  337. sub wait_child {
  338.     my ($pid, %opts) = @_;
  339.     $opts{"cmdline"} ||= _g("child process");
  340.     internerr("no PID set, cannot wait end of process") unless $pid;
  341.     eval {
  342.         local $SIG{ALRM} = sub { die "alarm\n" };
  343.         alarm($opts{"timeout"}) if defined($opts{"timeout"});
  344.         $pid == waitpid($pid, 0) or syserr(_g("wait for %s"), $opts{"cmdline"});
  345.         alarm(0) if defined($opts{"timeout"});
  346.     };
  347.     if ($@) {
  348.         die $@ unless $@ eq "alarm\n";
  349.         error(ngettext("%s didn't complete in %d second",
  350.                        "%s didn't complete in %d seconds",
  351.                        $opts{"timeout"}),
  352.               $opts{"cmdline"}, $opts{"timeout"});
  353.     }
  354.     unless ($opts{"nocheck"}) {
  355.     subprocerr($opts{"cmdline"}) if $?;
  356.     }
  357. }
  358.  
  359. 1;
  360. __END__
  361.  
  362. =back
  363.  
  364. =head1 AUTHORS
  365.  
  366. Written by Rapha├½l Hertzog <hertzog@debian.org> and
  367. Frank Lichtenheld <djpig@debian.org>.
  368.  
  369. =head1 SEE ALSO
  370.  
  371. Dpkg, Dpkg::ErrorHandling
  372.